home *** CD-ROM | disk | FTP | other *** search
/ PC Media 2 / PC MEDIA CD02.iso / share / prog / adacompl / augusta.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1985-10-29  |  18.9 KB  |  468 lines
  1. 1  ' **************************************
  2. 2  ' *<UNK! {0009}><UNK! {0009}><UNK! {0009}><UNK! {0009}><UNK! {0009}> *
  3. 3  ' *   Augusta.bas - a public domain    *
  4. 4  ' *   subset of the US Department of   *
  5. 5  ' *   Defense computer language Ada.   *
  6. 6  ' *<UNK! {0009}><UNK! {0009}><UNK! {0009}><UNK! {0009}><UNK! {0009}> *
  7. 7  ' **************************************
  8. 8  '
  9. 10  '
  10. 100  '
  11. 1000  DEFINT A-Z:CLS:KEY OFF:PRINT"Augusta(tm) Compiler v1.1A":PRINT"(C) Copyright 1983 by Computer Linguistics":PRINT"All rights reserved."
  12. 1003  DIM MAP(26),KEYWD$(33),S$(100),TY(20),B$(3),B(3),S(500)
  13. 1010  PRINT:PRINT"Initializing ...":GOSUB 1780:GOSUB 1110:SI=1:PRINT:INPUT"Source file ? ",S$:GOSUB 1230
  14. 1020  INPUT"Code file ? ",C$:OPEN"R",#1,C$,128:CLOSE 1:KILL C$
  15. 1040  INPUT"Listing (Y/CR)? ",T1$:OPEN"R",#1,C$,128:R0=16:M0=R0:IF T1$="Y" THEN PLST=-1:LPRINT LP$;
  16. 1050  GOSUB 1290:GOSUB 1400:PRINT FRE("");" Bytes for symbols":GOSUB 1980
  17. 1060  PUT #1,R0:FIELD #1,2 AS T1$,2 AS T2$,2 AS T3$,2 AS D$,2 AS S$
  18. 1070  LSET T1$=MKI$(GC):LSET T2$=MKI$(M0):LSET T3$=MKI$(PROC):LSET D$=MKI$(0):LSET S$=MKI$(1113)
  19. 1080  PUT #1,1:FIELD #1,128 AS D$:FOR I=1 TO MB:IF B(I)<>0 AND B(I)<>R0 THEN LSET D$=B$(I):PUT #1,B(I)
  20. 1090  NEXT I:CLOSE 1:PRINT:PRINT"Compiled OK":PRINT LN;" LINES. ";GC-1920;" bytes":GOTO 32767
  21. 1110  ' ********* Init
  22. 1120  QUOTE$=CHR$(34):LEXCH$=ALF$+DIG$+" @*+=-<>/:;')(,"+QUOTE$+".#!"+CHR$(3)+CHR$(96)+CHR$(9):CLST=-1
  23. 1130  SQUOTE=0:EOL=1:C=2:LP=3:RP=4:MUL=5:DIV=6:ADD=7:SUBT=8:LES=9:LEQ=10:GT=11:GEQ=12:EQ=13:NEQ=14:BAR=15:ID=16
  24. 1135  SC=17:COMMA=18:SEMICOLON=19:COLON=20:EQGT=21:COLONEQ=22:DOT=23:DOTDOT=24:CH=25:AT=26
  25. 1140  KAND=27:KARRAY=28:KBEGIN=29:KCASE=30:KCONST=31:KDECLARE=32:KELSE=33:KELSEIF=34:KEND=35:KEXIT=36:KFOR=37:KFUNC=38:KIF=39
  26. 1145  KIN=40:KIS=41:KLOOP=42:KLAST=43:KLEN=44:KMOD=45:KNOT=46:KNULL=47:KOF=48:KOR=49:KOTHERS=50:KOUT=51
  27. 1150  KPRAGMA=52:KPROC=53:KRET=54:KREVERSE=55:KTHEN=56:KWHEN=57:KWHILE=58
  28. 1160  ADDOP$=CHR$(ADD)+CHR$(SUBT):MULOP$=CHR$(MUL)+CHR$(DIV)+CHR$(KMOD):LOGICALOP$=CHR$(KAND)+CHR$(KOR)
  29. 1165  UNARYOP$=CHR$(ADD)+CHR$(SUBT)+CHR$(KNOT):RELOP$=CHR$(LES)+CHR$(LEQ)+CHR$(GT)+CHR$(GEQ)+CHR$(EQ)+CHR$(NEQ)
  30. 1170  DECLPART$=CHR$(ID)+CHR$(KPROC)+CHR$(KFUNC)+CHR$(KPRAGMA)
  31. 1180  STMT$=CHR$(KWHILE)+CHR$(KFOR)+CHR$(KLOOP)+CHR$(KDECLARE)+CHR$(KBEGIN)+CHR$(KEXIT)+CHR$(KRET)+CHR$(KIF)
  32. 1185  STMT$=STMT$+CHR$(KCASE)+CHR$(KNULL)+CHR$(ID)+CHR$(PRAGMA)
  33. 1190  LN=1:EOI=0:LL=0:CPROC=0:PROC=0:GC=1920:VLOC=VARPTR(V):VLOC1=VLOC+1:TSTR=0:TINT=1:TCHR=2:TBOL=4:FMSZ=14
  34. 1200  PLDCI=1:PLDL=2:PLLA=3:PLDB=4:PLDO=5:PLAO=6:PDUP=7:PLOD=8:PLDA=9:PPOP=10:PSTO=11:PSINDO=12:PLCA=13:PSAS=14:PAND=16
  35. 1205  POR=17:PNOT=18:PADI=19:PNGI=20:PSBI=21:PMPI=22:PDVI=23:PIND=24:PEQUI=25:PNEQI=26:PLEQI=27:PSLDC=61:PINCL=80:PDECL=81
  36. 1210  PLESI=28:PGEQI=29:PGTRI=30:PEQUSTR=31:PNEQSTR=32:PLEQSTR=33:PLESSTR=34:PGEQSTR=35:PGTRSTR=36:PUJP=37:PFJP=38:PXJP=39
  37. 1215  PCLP=40:PCGP=41:PCSP=42:PRET=43:PMODI=45:PCIP=46:PRNP=47:PEOP=15:PSLDCN1=63:PIXA=48
  38. 1217  PSLDO=57:PSLAO=58:PSLLA=59:PSLDLO=49:PSLDL=60
  39. 1220  RETURN
  40. 1230  '********** Open Source
  41. 1240  SI=SI+1:OPEN"I",#SI,S$:RETURN
  42. 1250  '********** Convert to UPPERCASE
  43. 1260  IF INSTR(LC$,CH$) THEN CH$=CHR$(ASC(CH$)-32)
  44. 1270  RETURN
  45. 1280  '********** GetLine
  46. 1290  LN=LN+1:IF EOF(SI) THEN CLOSE SI:SI=SI-1:IF SI>1 AND PLST THEN LPRINT TAB(26);"* End of INCLUDE"
  47. 1300  IF SI=1 THEN EOI=-1:RETURN
  48. 1310  LINE INPUT #SI,BUF$
  49. 1320  IF PLST=0 THEN GOTO 1330 ELSE LPRINT USING"##### #### ###### ###### ";LN,CPROC,CP,OFST;:LPRINT LEFT$(BUF$,54)
  50. 1325  IF (LN MOD 60)=0 THEN LPRINT CHR$(12);:LPRINT:LPRINT
  51. 1330  IF CLST<>0 THEN PRINT BUF$ ELSE IF (LN AND 63)=63 THEN PRINT LN;"..."
  52. 1340  IF LEN(BUF$)=0 THEN 1290 ELSE BUF$=BUF$+CHR$(3):B=1:WHILE MID$(BUF$,B,1)=" ":B=B+1:WEND:CH$=MID$(BUF$,B,1):B=B+1:RETURN
  53. 1360  '********** GetCh
  54. 1370  LSET CH$=MID$(BUF$,B,1):B=B+1:RETURN
  55. 1380  B=B+1
  56. 1390  RETURN
  57. 1400  '********** GetSym
  58. 1410  OLDB=B:GOSUB 1250:I=INSTR(LEXCH$,CH$):IF I=0 THEN E=1:GOTO 5020
  59. 1420  IF I<27 THEN GOSUB 1460:GOTO 1430
  60. 1423  IF I<42 THEN ON I-26 GOSUB 1500,1500,1500,1500,1500,1500,1500,1500,1500,1500,1700,1770,1720,1520,1600:GOTO 1430
  61. 1427  ON I-41 GOSUB 1530,1620,1640,1660,1680,1540,1750,1570,1560,1550,1730,1580,1695,1710,1450,1440,1775
  62. 1430  IF EOI THEN E=12:GOTO 5020 ELSE IF OLDB=B THEN 1410 ELSE LSET TT$=CHR$(T):RETURN
  63. 1440  T=SQUOTE:GOSUB 1360:RETURN
  64. 1450  GOSUB 1290:OLDB=B:RETURN
  65. 1460  S$="":WHILE INSTR(AN$,CH$):IF CH$<>"_" THEN S$=S$+CH$
  66. 1470  GOSUB 1370:GOSUB 1260:WEND:IF LEN(S$)>8 THEN S$=LEFT$(S$,8)
  67. 1480  ID$=S$+SPACE$(8-LEN(S$)):GOSUB 1890:RETURN
  68. 1490  '********** Digits
  69. 1500  TN=0:I1=10
  70. 1510  WHILE INSTR(HDIG$,CH$):TN=TN*I1+INSTR(HDIG$,CH$)-1:GOSUB 1360:WEND
  71. 1515  IF CH$="#" THEN I1=TN:TN=0:GOSUB 1360:GOTO 1510 ELSE T=C:RETURN
  72. 1520  T=ADD:GOSUB 1360:RETURN
  73. 1530  T=SUBT:GOSUB 1360:IF CH$="-" THEN GOSUB 1280:OLDB=B:RETURN ELSE RETURN
  74. 1540  T=SEMICOLON:GOSUB 1360:RETURN
  75. 1550  T=COMMA:GOSUB 1360:RETURN
  76. 1560  T=LP:GOSUB 1360:RETURN
  77. 1570  T=RP:GOSUB 1360:RETURN
  78. 1580  T=DOT:GOSUB 1360:IF CH$="." THEN T=DOTDOT:GOSUB 1360
  79. 1590  RETURN
  80. 1600  GOSUB 1360:IF CH$=">" THEN T=EQGT:GOSUB 1360 ELSE T=EQ
  81. 1610  RETURN
  82. 1620  GOSUB 1360:IF CH$="=" THEN T=LEQ:GOSUB 1360 ELSE T=LES
  83. 1630  RETURN
  84. 1640  GOSUB 1360:IF CH$="=" THEN T=GEQ:GOSUB 1360 ELSE T=GT
  85. 1650  RETURN
  86. 1660  GOSUB 1360:IF CH$="=" THEN T=NEQ:GOSUB 1360 ELSE T=DIV
  87. 1670  RETURN
  88. 1680  GOSUB 1360:IF CH$="=" THEN T=COLONEQ:GOSUB 1360 ELSE T=COLON
  89. 1690  RETURN
  90. 1695  T=BAR:GOSUB 1360:RETURN
  91. 1700  WHILE CH$=" ":LSET CH$=MID$(BUF$,B,1):B=B+1:WEND:OLDB=B:RETURN
  92. 1710  T=BAR:GOSUB 1360:RETURN
  93. 1720  T=MUL:GOSUB 1360:RETURN
  94. 1730  I1=INSTR(B,BUF$,QUOTE$):IF I1=0 THEN E=10:GOTO 5020
  95. 1740  S$=MID$(BUF$,B,I1-B):T=SC:B=I1+1:GOSUB 1360:RETURN
  96. 1750  GOSUB 1360:GOSUB 1360:IF CH$<>"'" THEN E=11:GOTO 5020
  97. 1760  GOSUB 1360:GOSUB 1930:TN=ASC(MID$(S$,2,1)):T=CH:RETURN
  98. 1770  T=AT:GOSUB 1360:RETURN
  99. 1775  GOSUB 1360:OLDB=B:RETURN
  100. 1780  '********** Read Data
  101. 1790  CH$=" ":B=0:LB=0:AN$=CH$:LC$=CH$:S$=CH$:T=0:T0=0:X=0:SP=0:TSP=0:LEXCH$=S$:CP=0:CB=0:W=0:I=0:R2=0:R1=0:T3=0:R0=16
  102. 1795  D$=S$:LOC1=0:LOC2=0:V=0:VLOC=0:VLOC1=0:TN=0:TT$=S$:HASH=0:ID$=S$:BUF$=S$:T1=0:T2=0
  103. 1800  NKEY=33:SSP=1:MB=3:FOR I=0 TO MB:B$(I)=SPACE$(128):B(I)=0:NEXT I
  104. 1820  OPEN"I",#1,"keywords.txt":LINE INPUT #1,LC$:T1=1:WHILE T1>0:INPUT #1,T1:LP$=LP$+CHR$(T1):WEND
  105. 1830  INPUT #1,DIG$,HDIG$,ALF$,LC$,AN$
  106. 1840  FOR I=1 TO 26:INPUT #1,MAP(I):NEXT I
  107. 1850  I=1:INPUT #1,ID$,TYPE,KIND,PINFO,CONST,OBJSZ,ADDR,LL:IF ID$<>"*END*" THEN ID$=ID$+SPACE$(8-LEN(ID$)):GOSUB 3850:GOTO 1850
  108. 1860  IF EOF(1) THEN 1880 ELSE INPUT #1,T$:IF LEN(T$)>8 THEN T$=LEFT$(T$,8)
  109. 1870  T$=T$+SPACE$(8-LEN(T$)):KEYWD$(I)=T$:I=I+1:GOTO 1860
  110. 1880  CLOSE 1:KEYWD$(0)=" ":KEYWD$(NKEY)=" ":RETURN
  111. 1890  '********** LookupKeyword
  112. 1900  HASH=MAP(INSTR(ALF$,LEFT$(ID$,1)))
  113. 1910  IF KEYWD$(HASH)=ID$ THEN T=HASH+26 ELSE IF ASC(KEYWD$(HASH))<>ASC(ID$) THEN T=ID ELSE HASH=HASH+1:GOTO 1910
  114. 1920  RETURN
  115. 1930  '********** Get S$
  116. 1940  S$=MID$(BUF$,OLDB-1,B-OLDB):RETURN
  117. 1950  IF T0=T THEN RETURN
  118. 1955  E=4:GOSUB 5110:PRINT"Reenter+ ";:LINE INPUT T$:BUF$=LEFT$(BUF$,B-1)+T$+CHR$(3):GOSUB 1360:GOSUB 1400:GOTO 1950
  119. 1960  IF T0=T THEN GOSUB 1400:RETURN ELSE GOSUB 1950:GOSUB 1400:RETURN
  120. 1970  '********** Compilation
  121. 1980  GOSUB 2770
  122. 1990  IF T=KPROC THEN GOSUB 1400:GOSUB 2010:T0=SEMICOLON:GOSUB 1950
  123. 2000  RETURN
  124. 2010  '********** Parse Proc
  125. 2020  GOSUB 5200
  126. 2030  KIND=2:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:GOSUB 1400
  127. 2040  OFST=-FMSZ:IF T=KIS THEN 2060
  128. 2050  GOSUB 2100:T0=KIS:GOSUB 1950
  129. 2060  '********** Is
  130. 2070  X=-(OFST+FMSZ):GOSUB 4280:GOSUB 1400:OFST=0:MXOF=0:GOSUB 2440:W=PRET:GOSUB 3990:GOSUB 5300:RETURN
  131. 2100  '********** ProcFormalPart
  132. 2110  T2$="":T0=LP:GOSUB 1960
  133. 2120  GOSUB 2160:IF T=SEMICOLON THEN GOSUB 1400:GOTO 2120
  134. 2130  T0=RP:GOSUB 1960:FOR I=OFST TO-FMSZ-2 STEP 2:T1$=LEFT$(T2$,17):T2$=MID$(T2$,18):IF LEN(S$(SSP))+17)>255 THEN SSP=SSP+1
  135. 2140  S$(SSP)=LEFT$(T1$,14)+MKI$(I)+RIGHT$(T1$,1)+S$(SSP):NEXT I
  136. 2150  RETURN
  137. 2160  '********** ProcParamDecl
  138. 2170  T1$=""
  139. 2180  T0=ID:GOSUB 1950:T1$=T1$+ID$:GOSUB 1400
  140. 2190  IF T=COMMA THEN GOSUB 1400:GOTO 2180
  141. 2200  T0=COLON:GOSUB 1960:P1=1:IF T=KOUT THEN P1=2:GOSUB 1400:GOTO 2220
  142. 2210  IF T=KIN THEN GOSUB 1400
  143. 2220  GOSUB 2250:PINFO=P1
  144. 2230  WHILE LEN(T1$)>0:T2$=T2$+LEFT$(T1$,8)+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(0)+CHR$(LL)
  145. 2235  T1$=MID$(T1$,9):OFST=OFST-2:WEND
  146. 2240  RETURN
  147. 2250  '********** SubtypeIdentificationUnit
  148. 2260  GOSUB 3890:IF KIND<>4 THEN E=8:GOTO 5020 ELSE IF PINFO=0 THEN KIND=1 ELSE KIND=5
  149. 2280  IF TYPE<>0 THEN GOSUB 1400:RETURN
  150. 2285  GOSUB 2300:IF OBJSZ>255 THEN E=15:GOTO 5020 ELSE RETURN
  151. 2290  '********** Get C
  152. 2293  IF T<>ID THEN GOTO 2297 ELSE T8=TYPE:T3=KIND:T4=PINFO:T5=CONST:T6=OBJSZ:T7=LL
  153. 2294  GOSUB 3890:IF KIND=0 AND TYPE=1 THEN T=C:T2=CONST
  154. 2295  TYPE=T8:KIND=T3:PINFO=T4:CONST=T5:OBJSZ=T6:LL=T7
  155. 2297  T0=C:GOSUB 1960:RETURN
  156. 2300  '********** ObjSz
  157. 2310  GOSUB 1400:IF T<>LP THEN 2330 ELSE GOSUB 1400
  158. 2320  GOSUB 2290:OBJSZ=TN+1:T0=RP:GOSUB 1960
  159. 2330  RETURN
  160. 2340  '********** ParseFunc
  161. 2350  GOSUB 5200:KIND=3:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:X=SSP:GOSUB 4280:X=LEN(S$(SSP))
  162. 2355  GOSUB 4280:GOSUB 1400
  163. 2370  OFST=-FMSZ:IF T=LP THEN GOSUB 2100
  164. 2380  T0=KRET:GOSUB 1960:GOSUB 2250:GOSUB 4300:T2=X:GOSUB 4300:T1=X:T3=LEN(S$(T1)):IF KIND<>5 OR OBJSZ<>2 THEN E=16:GOTO 5020
  165. 2385  S$(T1)=LEFT$(S$(T1),T3-T2+8)+CHR$(TYPE)+MID$(S$(T1),T3-T2+10)
  166. 2400  T0=KIS:GOSUB 1960
  167. 2410  X=-(OFST+FMSZ):GOSUB 4280:OFST=0:MXOF=0:GOSUB 2440:GOSUB 5300:RETURN
  168. 2440  '********** BodyPart
  169. 2450  IF INSTR(DECLPART$,TT$) THEN GOSUB 2480
  170. 2460  CB=GC:CP=0:GOSUB 2790
  171. 2470  RETURN
  172. 2480  '********** DeclPart
  173. 2490  IF T=ID THEN T1$=ID$:K1=5:GOSUB 2560:GOTO 2540
  174. 2500  IF T=KPROC THEN GOSUB 1400:GOSUB 2010:GOTO 2540
  175. 2510  IF T=KFUNC THEN GOSUB 1400:GOSUB 2340:GOTO 2540
  176. 2520  IF T=KPRAGMA THEN GOSUB 2770:GOTO 2550
  177. 2530  E=3:GOTO 5020
  178. 2540  GOSUB 3420
  179. 2550  IF INSTR(DECLPART$,TT$) THEN 2480 ELSE GOSUB 4990:RETURN
  180. 2560  '********** ObjDecl
  181. 2570  GOSUB 1400
  182. 2580  IF T=COMMA THEN GOSUB 1400:T0=ID:GOSUB 1950:T1$=T1$+ID$:GOTO 2570
  183. 2590  T0=COLON:GOSUB 1960
  184. 2600  IF T=KCONST THEN 2650
  185. 2610  IF T=KARRAY THEN 2700
  186. 2620  GOSUB 2250:OBJSIZE=OBJSZ
  187. 2630  PINFO=0:KIND=K1:WHILE LEN(T1$)>0:ID$=LEFT$(T1$,8):T1$=MID$(T1$,9):ADDR=OFST:OFST=OFST+OBJSIZE:GOSUB 3850:WEND
  188. 2640  RETURN
  189. 2650  '********** Constant
  190. 2670  K1=0:OBJSIZE=0:GOSUB 1400:T0=COLONEQ:GOSUB 1960:IF T=ID THEN GOSUB 3890:GOTO 2690 ELSE IF T=SUBT THEN T1=-1:GOSUB 1400 ELSE T1=1
  191. 2680  CONST=TN*T1:IF T=C THEN TYPE=1 ELSE TYPE=2
  192. 2690  GOSUB 1400:GOTO 2630
  193. 2700  '********** Array
  194. 2710  K1=1:GOSUB 1400:T0=LP:GOSUB 1960:T2=TN:GOSUB 2290:T0=RP:GOSUB 1960:T0=KOF:GOSUB 1960
  195. 2750  GOSUB 2250:CONST=T2:OBJSIZE=(T2+1)*OBJSZ:IF T2<0 OR T2>16383 THEN E=15:GOTO 5020 ELSE 2630
  196. 2770  '********** Pragma
  197. 2780  IF T<>KPRAGMA THEN RETURN ELSE GOSUB 4830:GOSUB 1280:GOSUB 1400:GOTO 2780
  198. 2790  '********** Stmt
  199. 2800  T0=KBEGIN:GOSUB 1960:GOSUB 2810:T0=KEND:GOSUB 1960:RETURN
  200. 2810  '********** SeqOfStmts
  201. 2820  I=INSTR(STMT$,TT$)
  202. 2825  IF I=0 THEN RETURN ELSE ON I GOSUB 4320,4320,4320,2850,2850,2890,2930,2970,4630,2830,3440,2770:GOTO 2820
  203. 2830  '********** Null
  204. 2840  GOSUB 1400:GOSUB 3420:RETURN
  205. 2850  '********** Block
  206. 2860  X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 5400:IF T=KDECLARE THEN GOSUB 1400:GOSUB 2480
  207. 2880  GOSUB 2790:GOSUB 5500:GOSUB 5700:GOSUB 4300:OFST=X:GOSUB 3420:RETURN
  208. 2890  '********** Exit
  209. 2900  IF LPFLG=0 THEN E=14:GOTO 5020
  210. 2910  GOSUB 1400:IF T=SEMICOLON THEN W=PUJP:GOSUB 3990:GOTO 2925
  211. 2920  T0=KWHEN:GOSUB 1960:GOSUB 3100:GOSUB 4930:W=PNOT:GOSUB 3990:W=PFJP:GOSUB 3990
  212. 2925  W=XITJP:XITJP=CP:GOSUB 4030:GOSUB 3420:RETURN
  213. 2930  '********** Return
  214. 2940  GOSUB 1400
  215. 2950  IF T<>SEMICOLON THEN GOSUB 3100:TSP=TSP-1:W=PRNP ELSE W=PRET
  216. 2960  GOSUB 3990:GOSUB 3420:RETURN
  217. 2970  '********** If
  218. 2980  LUJP=0
  219. 2990  GOSUB 1400:GOSUB 3100:GOSUB 4930:W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:X=LUJP:GOSUB 4280
  220. 2995  T0=KTHEN:GOSUB 1960:GOSUB 2810:GOSUB 4300:LUJP=X
  221. 3000  IF T=KEND THEN GOSUB 3040:GOTO 3030
  222. 3010  IF T=KELSEIF THEN GOSUB 3060:GOSUB 3040:GOTO 2990
  223. 3020  T0=KELSE:GOSUB 1960:GOSUB 3060:GOSUB 3040:X=LUJP:GOSUB 4280:GOSUB 2810:GOSUB 4300:LUJP=X
  224. 3030  T0=KEND:GOSUB 1960:T0=KIF:GOSUB 1960:GOSUB 3080:GOSUB 3420:RETURN
  225. 3040  '********** Fix FJP
  226. 3050  GOSUB 4300:T1=CP:CP=X:W=T1-X-2:GOSUB 4030:CP=T1:RETURN
  227. 3060  '********** Gen UJP
  228. 3070  W=PUJP:GOSUB 3990:W=LUJP:LUJP=CP:GOSUB 4030:RETURN
  229. 3080  '********** Fixup
  230. 3090  T2=CP:WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
  231. 3100  '********** Expr
  232. 3110  GOSUB 3190:LFJP=0:PREV=0
  233. 3120  IF INSTR(LOGICALOP$,TT$)=0 THEN IF PREV THEN 3180 ELSE RETURN
  234. 3125  X=T:GOSUB 1400:IF (X=KAND AND T=KTHEN) THEN X=KAND+KTHEN ELSE IF (X=KOR AND T=KELSE) THEN X=KOR+KELSE
  235. 3130  IF PREV<>0 THEN IF PREV<>X THEN E=10:GOTO 5020
  236. 3140  IF X<>KAND AND X<>KOR THEN 3160
  237. 3145  GOSUB 4280:GOSUB 3190:IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
  238. 3147  TSP=TSP-1:GOSUB 4300:PREV=X:IF X=KAND THEN W=PAND ELSE W=POR
  239. 3150  GOSUB 3990:GOTO 3120
  240. 3160  GOSUB 4280:T1=X:W=PDUP:GOSUB 3990:IF T1=KAND+KTHEN THEN W=PFJP ELSE W=PNOT:GOSUB 3990:W=PFJP
  241. 3170  GOSUB 3990:W=LFJP:LFJP=CP:GOSUB 4030:GOSUB 1400:X=LFJP:GOSUB 4280:GOSUB 3190
  242. 3174  IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
  243. 3175  TSP=TSP-1:GOSUB 4300:LFJP=X:GOSUB 4300:PREV=X:IF X=KAND+KTHEN THEN W=PAND ELSE W=POR
  244. 3178  GOSUB 3990:GOTO 3120
  245. 3180  T2=CP:WHILR LFJP<>0:CP=LFJP:GOSUB 4010:LFJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
  246. 3190  '********** Relation
  247. 3200  GOSUB 3300
  248. 3210  IF INSTR(RELOP$,TT$)=0 THEN RETURN
  249. 3220  X=T:GOSUB 4280:GOSUB 1400
  250. 3230  GOSUB 3290:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR AND TY(TSP)<>TBOL THEN 3260
  251. 3235  IF TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
  252. 3240  GOSUB 4300:IF X=LES THEN W=PLESI ELSE IF X=LEQ THEN W=PLEQI ELSE IF X=GT THEN W=PGTRI
  253. 3245  IF X=GEQ THEN W=PGEQI ELSE IF X=EQ THEN W=PEQUI ELSE IF X=NEQ THEN W=PNEQI
  254. 3250  GOSUB 3990:GOTO 3210
  255. 3260  IF TY(TSP)<>TSTR OR TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
  256. 3270  GOSUB 4300:IF X=LES THEN W=PLESSTR ELSE IF X=LEQ THEN W=PLEQSTR ELSE IF X=GT THEN W=PGTRSTR
  257. 3275  IF X=GEQ THEN W=PGEQSTR ELSE IF X=EQ THEN W=PEQUSTR ELSE IF X=NEQ THEN W=PNEQSTR
  258. 3280  GOSUB 3990:GOTO 3210
  259. 3290  '********** SE
  260. 3300  IF INSTR(UNARYOP$,TT$) THEN X=T:GOSUB 4280:X=1:GOSUB 4280:GOSUB 1400 ELSE X=0:GOSUB 4280
  261. 3310  GOSUB 3350:GOSUB 4300:IF X=1 THEN GOSUB 4300:IF X=SUBT THEN W=PNGI:GOSUB 3990 ELSE W=PNOT:GOSUB 3990
  262. 3320  IF INSTR(ADDOP$,TT$)=0 THEN RETURN
  263. 3330  X=T:GOSUB 4280:GOSUB 1400:GOSUB 3350:GOSUB 4300:IF X=ADD THEN W=PADI ELSE W=PSBI
  264. 3340  IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 3990:GOTO 3320
  265. 3350  '********** Term
  266. 3360  GOSUB 3610
  267. 3370  IF INSTR(MULOP$,TT$)=0 THEN RETURN
  268. 3380  X=T:GOSUB 4280:GOSUB 1400:GOSUB 3610
  269. 3390  IF TY(TSP)<>TY(TSP-1) OR (TY(TSP)<>TINT) THEN E=9:GOTO 5020 ELSE TSP=TSP-1
  270. 3400  GOSUB 4300:IF X=MUL THEN W=PMPI ELSE IF X=DIV THEN W=PDVI ELSE W=PMODI
  271. 3410  GOSUB 3990:GOTO 3370
  272. 3420  '********** Skip
  273. 3430  IF T=SEMICOLON THEN GOSUB 1400:RETURN ELSE E=13:GOSUB 5110:RETURN
  274. 3440  '********** ID
  275. 3450  GOSUB 3890:IF KIND<>2 THEN X=TYPE:GOSUB 4280:GOSUB 3490:GOTO 3530 ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
  276. 3460  GOSUB 1400:IF T=SEMICOLON THEN 3480 ELSE T0=LP:GOSUB 1960
  277. 3470  GOSUB 3570:T0=RP:GOSUB 1960
  278. 3480  GOSUB 4100:GOSUB 3420:RETURN
  279. 3490  GOSUB 4060:GOSUB 1400
  280. 3500  IF KIND<>1 THEN RETURN ELSE X=OBJSZ:GOSUB 4280
  281. 3510  T0=LP:GOSUB 1960:GOSUB 3100:GOSUB 4960:GOSUB 4300:IF X=2 THEN W=PIND ELSE W=PIXA:GOSUB 3990:W=X
  282. 3520  GOSUB 3990:T0=RP:GOSUB 1960:RETURN
  283. 3530  T0=COLONEQ:GOSUB 1960
  284. 3540  GOSUB 3100:GOSUB 4300:IF NOT (X=TY(TSP) OR (X=TINT AND TY(TSP)=TBOL) OR (X=TBOL AND TY(TSP)=TINT)) THEN E=9:GOTO 5020
  285. 3550  IF X=TSTR THEN W=PSAS ELSE W=PSTO
  286. 3560  TSP=TSP-1:GOSUB 3990:GOSUB 3420:RETURN
  287. 3570  '********** ActualParam
  288. 3580  IF T=AT THEN GOSUB 1400:T0=ID:GOSUB 1950:GOSUB 3890:GOSUB 3490 ELSE GOSUB 3100:TSP=TSP-1
  289. 3590  IF T=COMMA THEN GOSUB 1400:GOTO 3580
  290. 3600  RETURN
  291. 3610  '********** Primary
  292. 3620  IF T=LP THEN GOSUB 1400:GOSUB 3100:T0=RP:GOSUB 1960:RETURN
  293. 3630  IF T=C THEN TSP=TSP+1:TY(TSP)=TINT:GOSUB 3640:GOSUB 1400:RETURN
  294. 3633  IF T=CH THEN TSP=TSP+1:TY(TSP)=TCHR:GOSUB 3640:GOSUB 1400:RETURN ELSE 3650
  295. 3635  '********** LD Cons
  296. 3640  IF TN=-1 THEN W=PSLDCN1:GOTO 3645 ELSE IF TN>-1 AND TN<16 THEN W=64+TN:GOTO 3645
  297. 3643  IF TN>0 AND TN<256 THEN W=PSLDC:GOSUB 3990:W=TN:GOSUB 3990:RETURN ELSE W=PLDCI:GOSUB 3990:W=TN:GOSUB 4030:RETURN
  298. 3645  GOSUB 3990:RETURN
  299. 3650  IF T<>SC THEN 3670 ELSE TSP=TSP+1:TY(TSP)=TSTR
  300. 3660  W=PLCA:GOSUB 3990:W=LEN(S$):GOSUB 3990:FOR I=1 TO LEN(S$):W=ASC(MID$(S$,I)):GOSUB 3990:NEXT I:GOSUB 1400:RETURN
  301. 3670  T0=ID:GOSUB 1950
  302. 3680  GOSUB 3890:IF KIND=0 THEN TSP=TSP+1:TY(TSP)=TYPE:TN=CONST:GOSUB 3640:GOSUB 1400:RETURN
  303. 3682  GOSUB 1400:IF T=SQUOTE THEN 3780
  304. 3685  IF KIND=4 THEN X=TYPE:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100:T0=RP:GOSUB 1960:GOSUB 4300:TY(TSP)=X:RETURN
  305. 3690  TSP=TSP+1:TY(TSP)=TYPE:IF TYPE=0 THEN 3800
  306. 3700  IF KIND<>1 THEN 3740 ELSE GOSUB 4060
  307. 3710  T0=LP:GOSUB 1960
  308. 3720  GOSUB 3100:IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:W=PIND:GOSUB 3990:W=PSINDO:GOSUB 3990
  309. 3730  T0=RP:GOSUB 1960:RETURN
  310. 3740  IF KIND<>3 THEN GOSUB 3760:RETURN ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
  311. 3745  IF T=LP THEN GOSUB 1400:GOSUB 3570:T0=RP:GOSUB 1960
  312. 3750  GOSUB 4100:RETURN
  313. 3760  GOSUB 3820:IF PINFO=2 THEN W=PSINDO:GOSUB 3990
  314. 3770  RETURN
  315. 3780  TSP=TSP+1:TY(TSP)=TINT:GOSUB 1400:IF T=KLAST THEN W=PLDCI:GOSUB 3990:W=CONST:GOSUB 4030:GOTO 3790
  316. 3785  IF T=KLEN THEN GOSUB 4060:W=PLDB:GOSUB 3990 ELSE E=7:GOTO 5020
  317. 3790  GOSUB 1400:RETURN
  318. 3800  IF KIND<>1 THEN 3810 ELSE GOSUB 4060:X=OBJSZ:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100
  319. 3805  IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 4300:W=PIXA:GOSUB 3990:W=X:GOSUB 3990:T0=RP:GOSUB 1960:RETURN
  320. 3810  GOSUB 4060:RETURN
  321. 3820  '********** LD Val
  322. 3830  IF LEX=1 THEN 3831 ELSE IF LEX=LL THEN 3834 ELSE W=PLOD:GOSUB 3990:W=LL-LEX:GOTO 3845
  323. 3831  '********** Global
  324. 3832  IF ADDR<256 THEN W=PSLDO:GOTO 3840 ELSE W=PLDO:GOTO 3845
  325. 3834  '********** LDL
  326. 3835  IF ADDR>=0 AND ADDR<8 THEN W=PSLDLO+ADDR:GOSUB 3990:RETURN
  327. 3836  IF ADDR>0 AND ADDR<8 THEN W=PSLDL:GOTO 3840 ELSE W=PLDL:GOTO 3845
  328. 3840  '********** B,B
  329. 3842  GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
  330. 3845  '********** B,W
  331. 3847  GOSUB 3990:W=ADDR:GOSUB 4030:RETURN
  332. 3850  '********** Add ID
  333. 3860  IF LEN(S$(SSP))+17>255 THEN SSP=SSP+1
  334. 3870  S$(SSP)=ID$+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(ADDR)+CHR$(LL)+S$(SSP)
  335. 3880  RETURN
  336. 3890  '********** Lookup ID
  337. 3900  LOC1=SSP
  338. 3910  LOC2=INSTR(S$(LOC1),ID$):IF LOC2 THEN 3920 ELSE LOC1=LOC1-1:IF LOC1 THEN 3910 ELSE E=2::GOTO 5020
  339. 3920  T9=VARPTR(S$(LOC1)):POKE VLOC,PEEK(T9+1):POKE VLOC1,PEEK(T9+2):T9=V+LOC2-1
  340. 3930  TYPE=PEEK(T9+8):KIND=PEEK(T9+9):PINFO=PEEK(T9+10):POKE VLOC,PEEK(T9+11):POKE VLOC1,PEEK(T9+12):CONST=V
  341. 3960  OBJSZ=PEEK(T9+13):LEX=PEEK(T9+16):POKE VLOC,PEEK(T9+14):POKE VLOC1,PEEK(T9+15):ADDR=V:RETURN
  342. 3990  '********** GenByte
  343. 4000  GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:LSET D$=CHR$(W):CP=CP+1:RETURN
  344. 4010  '********** read wrd
  345. 4020  T1=CP:GOSUB 4260:POKE VLOC,W:CP=CP+1:GOSUB 4260:POKE VLOC1,W:W=V:CP=T1:RETURN
  346. 4030  '********** GenWord W
  347. 4040  GOSUB 4140:IF R2<127 THEN FIELD #1,R2 AS D$,2 AS D$:LSET D$=MKI$(W):CP=CP+2:RETURN
  348. 4050  V=W:W=PEEK(VLOC):GOSUB 3990:W=PEEK(VLOC1):GOSUB 3990:RETURN
  349. 4060  '********** LD Adr
  350. 4070  IF PINFO=2 THEN GOSUB 3820 RETURN
  351. 4080  IF LEX=1 THEN 4085 ELSE IF LEX=LL THEN 4090 ELSE W=PLDA:GOSUB 3990:W=LL-LEX:GOTO 3845
  352. 4085  '********** GL Adr
  353. 4087  IF ADDR<256 THEN W=PSLAO:GOTO 3840 ELSE W=PLAO:GOTO 3845
  354. 4090  '********** LDL Adr
  355. 4095  IF ADDR>=0 AND ADDR<256 THEN W=PSLLA:GOTO 3840 ELSE W=PLLA:GOTO 3845
  356. 4100  '********** Call Proc
  357. 4110  GOSUB 4300:LEX=X:GOSUB 4300:ADDR=X
  358. 4120  IF LEX=0 THEN W=PCSP ELSE IF LEX=2 THEN W=PCGP ELSE IF LEX=LL+1 THEN W=PCLP ELSE W=PCIP
  359. 4130  GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
  360. 4140  '********** GetBuf
  361. 4150  T9=CP+CB:R1=T9\128+1:R2=T9 AND 127:IF R1=R0 THEN RETURN
  362. 4160  FIELD #1,128 AS D$:J=1
  363. 4170  IF B(J)=R0 OR B(J)=0 THEN 4190 ELSE J=J+1:IF J<=MB THEN 4170
  364. 4180  LSET B$(0)=D$:J=INT(RND*MB)+1:LSET D$=B$(J):PUT #1,B(J):LSET B$(J)=B$(0):B(J)=R0:GOTO 4200
  365. 4190  LSET B$(J)=D$:B(J)=R0
  366. 4200  J=1
  367. 4210  IF B(J)=R1 THEN 4240 ELSE J=J+1:IF J<=MB THEN 4210
  368. 4220  GET #1,R1:R0=R1:IF R1>M0 THEN M0=R1
  369. 4230  RETURN
  370. 4240  LSET D$=B$(J):R0=R1:IF R1>M0 THEN M0=R1
  371. 4250  RETURN
  372. 4260  '********** ReadByte
  373. 4270  GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:W=ASC(D$):RETURN
  374. 4280  '********** Push
  375. 4290  S(SP)=X:SP=SP+1:RETURN
  376. 4300  '********** Pop
  377. 4310  SP=SP-1:X=S(SP):RETURN
  378. 4320  '********** Loop
  379. 4330  IF T<>KWHILE THEN 4370
  380. 4340  GOSUB 1400:X=CP:GOSUB 4280:GOSUB 3100:GOSUB 4930
  381. 4350  W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:W=0:GOSUB 4030:GOSUB 4590:GOSUB 4300
  382. 4360  T1=CP:CP=X:W=T1-X+1:GOSUB 4030:CP=T1:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
  383. 4370  IF T<>KFOR THEN 4580
  384. 4380  GOSUB 1400:T0=ID:GOSUB 1950:X=OFST:GOSUB 4280:GOSUB 5400
  385. 4390  ADDR=OFST:TYPE=1:KIND=5:PINFO=0:GOSUB 3850
  386. 4400  GOSUB 1400:T0=KIN:GOSUB 1960
  387. 4410  IF T=KREVERSE THEN X=-1:GOSUB 1400 ELSE X=1
  388. 4420  GOSUB 4280:W=PLLA:GOSUB 3990:W=OFST:GOSUB 4030
  389. 4430  GOSUB 3290:GOSUB 4960:W=PSTO:GOSUB 3990
  390. 4440  X=CP:GOSUB 4280:W=PLDL:GOSUB 3990:W=OFST:GOSUB 4030
  391. 4450  T0=DOTDOT:GOSUB 1960:GOSUB 3290:GOSUB 4960
  392. 4460  GOSUB 4300:T1=X:GOSUB 4300:IF X<0 THEN W=PGEQI ELSE W=PLEQI
  393. 4470  GOSUB 3990:W=PFJP:GOSUB 3990:GOSUB 4280:X=T1:GOSUB 4280
  394. 4480  X=CP:GOSUB 4280:W=0:GOSUB 4030:X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 4990
  395. 4490  GOSUB 4590:GOSUB 4300:T3=X:GOSUB 4300:T1=X:GOSUB 4300:T2=X:GOSUB 4300:IF X<0 THEN W=PDECL ELSE W=PINCL
  396. 4500  GOSUB 3990:W=T3:GOSUB 4030
  397. 4520  W=PUJP:GOSUB 3990
  398. 4530  W=T2-CP-2:GOSUB 4030:T2=CP:CP=T1:W=T2-T1-2:GOSUB 4030:CP=T2
  399. 4550  GOSUB 5500:GOSUB 5700
  400. 4560  GOSUB 4300:OFST=X
  401. 4570  GOSUB 4620:RETURN
  402. 4580  X=CP:GOSUB 4280:GOSUB 4590:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
  403. 4590  T0=KLOOP:GOSUB 1960:X=XITJP:GOSUB 4280:XITJP=0:X=LPFLG:GOSUB 4280:LPFLG=-1:GOSUB 2810
  404. 4600  T0=KEND:GOSUB 1960
  405. 4610  T0=KLOOP:GOSUB 1960:GOSUB 4300:T5=X:GOSUB 4300:T6=X:GOSUB 3420:RETURN
  406. 4620  T2=CP:WHILE XITJP<>0:CP=XITJP:GOSUB 4010:XITJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:LPFLG=T5:XITJP=T6:RETURN
  407. 4630  '********** Case
  408. 4640  GOSUB 1400:GOSUB 3100:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR THEN E=9:GOTO 5020
  409. 4645  TSP=TSP-1:W=PXJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:GOSUB 4030:GOSUB 4030:CASES=0:LUJP=0:T0=KIS:GOSUB 1960
  410. 4650  T0=KWHEN:GOSUB 1960:IF T=KOTHERS THEN 4810 ELSE T1=0
  411. 4660  IF T=ID THEN GOSUB 3890:TN=CONST:IF TYPE=1 OR TYPE=2 THEN T=C
  412. 4670  IF T<>CH AND T<>C THEN E=5:GOTO 5020 ELSE X=TN:GOSUB 4280:T1=T1+1:GOSUB 1400:IF T=BAR THEN GOSUB 1400:GOTO 4660
  413. 4680  GOSUB 4780
  414. 4690  IF T=KWHEN THEN 4650 ELSE X=0:GOSUB 4280:GOSUB 4280:X=1:GOSUB 4280:CASES=CASES+1
  415. 4700  T0=KEND:GOSUB 1960:T0=KCASE:GOSUB 1960
  416. 4710  T1=SP-4:T3=32767:T4=-32767:FOR I=1 TO CASES-1:T2=S(T1):T1=T1-2:FOR J=1 TO T2:IF S(T1)<T3 THEN T3=S(T1)
  417. 4715  IF S(T1)>T4 THEN T4=S(T1)
  418. 4720  T1=T1-1:NEXT J:NEXT I:W=PUJP:GOSUB 3990:T5=CP:GOSUB 4300:GOSUB 4300:T1=X:GOSUB 4300
  419. 4725  IF X=-1 THEN W=T1-CP-2:GOSUB 4030 ELSE W=LUJP:LUJP=CP:GOSUB 4030
  420. 4730  FOR I=T3 TO T4:W=T5-CP-3:GOSUB 4030:NEXT I '*** build table
  421. 4740  T7=CP:FOR I=1 TO CASES-1:GOSUB 4300:T2=X:GOSUB 4300:T6=X:FOR T8=1 TO T2:GOSUB 4300
  422. 4745  CP=T5+(X-T3)*2+2:W=T6-CP-2:GOSUB 4030:NEXT T8:NEXT I:CP=T7
  423. 4750  GOSUB 4300:T2=CP:CP=X:W=T3:GOSUB 4030:W=T4:GOSUB 4030:W=T5-CP-2:GOSUB 4030
  424. 4760  WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2
  425. 4770  GOSUB 3420:RETURN
  426. 4780  T0=EQGT:GOSUB 1960:X=CP:GOSUB 4280:X=T1:GOSUB 4280:X=LUJP:GOSUB 4280:CASES=CASES+1:X=CASES:GOSUB 4280:GOSUB 2810
  427. 4790  W=PUJP:GOSUB 3990:GOSUB 4300:CASES=X:GOSUB 4300:LUJP=X
  428. 4800  W=LUJP:LUJP=CP:GOSUB 4030:RETURN
  429. 4810  '********** Others
  430. 4820  GOSUB 1400:X=-1:GOSUB 4280:T1=1:GOSUB 4780:GOTO 4700
  431. 4830  '********** Pragma
  432. 4840  GOSUB 1400:IF S$<>"LIST" THEN 4850
  433. 4845  GOSUB 4880:IF T$="ON" THEN PLST=-1:LPRINT LP$;:RETURN ELSE IF T$="OFF" THEN PLST=0:RETURN ELSE E=6:GOTO 5020
  434. 4850  IF S$="CRT" THEN GOSUB 4880:IF T$="ON" THEN CLST=-1:RETURN ELSE CLST=0:RETURN
  435. 4860  IF S$<>"INCLUDE" THEN RETURN ELSE GOSUB 1400:T0=LP:GOSUB 1960
  436. 4870  IF T<>SC THEN E=9:GOTO 5020 ELSE GOSUB 1230:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
  437. 4880  GOSUB 1400:T0=LP:GOSUB 1960:T$=S$:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
  438. 4910  '********** WriteProc
  439. 4920  T2=CP:T3=CB:CB=0:CP=(ADDR-1)*7+128:W=C1-1920:GOSUB 4030:W=L1:GOSUB 4030:W=P1:GOSUB 4030:W=LL:GOSUB 3990:CP=T2:CB=T3:RETURN
  440. 4930  '********** Check Bool
  441. 4940  IF TY(TSP)<>TBOL THEN E=9:GOTO 5020
  442. 4950  TSP=TSP-1:RETURN
  443. 4960  '********** Check Int
  444. 4970  IF TY(TSP)<>TINT THEN E=9:GOTO 5020
  445. 4980  TSP=TSP-1:RETURN
  446. 4990  '********** Max Offst
  447. 5000  IF OFST>MXOF THEN MXOF=OFST
  448. 5010  RETURN
  449. 5020  GOSUB 5100:STOP
  450. 5100  PRINT:PRINT"*** Error";E;" in line";LN:PRINT BUF$:PRINT TAB(B-1);"*":RETURN
  451. 5110  PRINT:PRINT T0;" expected":GOSUB 5100:RETURN
  452. 5200  '********** Proc DEF
  453. 5210  LL=LL+1:X=CPROC:GOSUB 4280:X=OFST:GOSUB 4280:X=MXOF:GOSUB 4280:T0=ID:GOSUB 1950
  454. 5220  GOSUB 5400:RETURN
  455. 5300  '********** Proc END DEF
  456. 5310  W=PEOP:GOSUB 3990:GOSUB 4300:P1=X:GOSUB 4300:ADDR=X:CPROC=X:L1=MXOF:C1=GC:GOSUB 4910:GC=GC+CP
  457. 5320  LL=LL-1:GOSUB 5500:GOSUB 5600
  458. 5330  GOSUB 4300:MXOF=X:GOSUB 4300:OFST=X:GOSUB 4300:CPROC=X:RETURN
  459. 5400  '********** Push Syms
  460. 5410  X=LEN(S$(SSP)):IF X=255 THEN SSP=SSP+1:X=0
  461. 5420  GOSUB 4280:X=SSP:GOSUB 4280:RETURN
  462. 5500  '********** Pop Syms
  463. 5510  GOSUB 4300:FOR I=X+1 TO SSP:S$(I)="":NEXT I:SSP=X:GOSUB 4300:LOC2=X:RETURN
  464. 5520  RETURN
  465. 5600  S$(SSP)=RIGHT$(S$(SSP),LOC2+17):RETURN
  466. 5700  S$(SSP)=RIGHT$(S$(SSP),LOC2):RETURN
  467. 32767  KEY ON: END
  468.